home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 3b.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  57.1 KB  |  1,970 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "3.h"
  11. #include "attr.h"
  12. #include "setprots.h"
  13. #include "dclmapprots.h"
  14. #include "errmsgprots.h"
  15. #include "evalprots.h"
  16. #include "nodesprots.h"
  17. #include "miscprots.h"
  18. #include "smiscprots.h"
  19. #include "chapprots.h"
  20.  
  21. static void new_unconstrained_array(Symbol, Node);
  22. static Symbol constrain_index(Symbol, Node);
  23. static void discr_decl(Node);
  24. static Tuple process_anons(Tuple);
  25. static int reformat_requires(Node);
  26.  
  27. Tuple apply_range(Node range_expr) /*;apply_range*/
  28. {
  29.     /* A'RANGE is equivalent to A'FIRST..A'LAST. When the range attribute
  30.      * is used as a constraint, the bounds are expressed according to the
  31.      * above equivalence. This is not strictly correct if the elaboration
  32.      * of A has side-effects, but we ignore this detail for now.
  33.      */
  34.  
  35.     Node    attr, arg1, arg2;
  36.     Tuple    new_c;
  37.     Node    l_node, f_node;
  38.     int    f, l, attr_kind;
  39.  
  40.     if (N_KIND(range_expr) == as_qual_range)
  41.         /* discard spurious constraint. */
  42.         range_expr = N_AST1(range_expr);
  43.     attr = N_AST1(range_expr);
  44.     arg1 = N_AST2(range_expr);
  45.     arg2 = N_AST3(range_expr);
  46.  
  47.     /* The attribute is either O_RANGE or T_RANGE, according as arg1 is an
  48.      * object or a type. FIRST and LAST must be marked accordingly.
  49.      */
  50.     /* In C note that base attribute kind followed by O_ kind, then T_. */
  51.     attr_kind = (int) attribute_kind(range_expr);
  52.  
  53.     if (attr_kind == ATTR_O_RANGE) {
  54.         f = ATTR_O_FIRST;
  55.         l = ATTR_O_LAST;
  56.     }
  57.     else {
  58.         f = ATTR_T_FIRST;
  59.         l = ATTR_T_LAST;
  60.     }
  61.  
  62.     f_node = new_attribute_node(f, arg1, arg2, N_TYPE(range_expr));
  63.     l_node = new_attribute_node(l, copy_tree(arg1), copy_tree(arg2),
  64.       N_TYPE(range_expr));
  65.  
  66.     N_KIND(range_expr) = as_range;
  67.     N_AST1(range_expr) = f_node;
  68.     N_AST2(range_expr) = l_node;
  69.  
  70.     /*return ?? ['range', f_node, l_node];*/
  71.     new_c = constraint_new(CONSTRAINT_RANGE);
  72.     numeric_constraint_low(new_c) = (char *) f_node;
  73.     numeric_constraint_high(new_c) = (char *) l_node;
  74.     return new_c;
  75. }
  76.  
  77. void array_typedef(Node node)                                /*;array_typedef*/
  78. {
  79.     Node index_list_node, type_indic_node;
  80.     Tuple index_nodes;
  81.     Node indx_node, indx1_node;
  82.     Tuple index_type_list;
  83.     Symbol    element_type;
  84.     int i, exists;
  85.     Fortup    ft1;
  86.  
  87.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : array_typedef");
  88.  
  89.     index_list_node = N_AST1(node);
  90.     type_indic_node = N_AST2(node);
  91.     sem_list(index_list_node);
  92.     index_nodes = N_LIST(index_list_node);
  93.  
  94.     index_type_list =  tup_new(tup_size(index_nodes));
  95.     FORTUPI(indx_node =(Node), index_nodes, i, ft1);
  96.         index_type_list[i] = (char *) make_index(indx_node);
  97.     ENDFORTUP(ft1);
  98.  
  99.     adasem(type_indic_node);
  100.     element_type = promote_subtype(make_subtype(type_indic_node));
  101.  
  102.     /* Validate an array type definition.*/
  103.  
  104.     exists = FALSE;
  105.     FORTUP(indx_node =(Node) , index_nodes, ft1);
  106.         if (N_KIND(indx_node) == as_box) {
  107.             exists = TRUE;
  108.             break;
  109.         }
  110.     ENDFORTUP(ft1);
  111.     if (exists) {
  112.         exists = FALSE;
  113.         /*Unconstrained array . Verify that all indices are unconstrained.*/
  114.         FORTUP(indx1_node = (Node), index_nodes, ft1);
  115.             if (N_KIND(indx1_node) != as_box) {
  116.                 exists = TRUE;
  117.                 break;
  118.             }
  119.         ENDFORTUP(ft1);
  120.         if (exists) {
  121. #ifdef ERRNUM
  122.             errmsgn(194, 195, node);
  123. #else
  124.             errmsg("Constraints apply to all indices or none", "3.6.1", node);
  125. #endif
  126.         }
  127.     }
  128.     if (is_unconstrained(element_type)) {
  129. #ifdef ERRNUM
  130.         errmsgn(196, 132, type_indic_node);
  131. #else
  132.         errmsg("Unconstrained element type in array declaration",
  133.           "3.6.1, 3.7.2", type_indic_node);
  134. #endif
  135.     }
  136.     check_fully_declared2(element_type);
  137.  
  138.     for (i = 1; i<= tup_size(index_nodes); i++) {
  139.         Node tmp = (Node) index_nodes[i];
  140.         N_UNQ(tmp) = (Symbol) (index_type_list[i]);
  141.     }
  142.     N_UNQ(type_indic_node) = element_type;
  143. }
  144.  
  145. void new_array_type(Symbol array_type, Node def_node)  /*;new_array_type*/
  146. {
  147.     /* This     procedure  is    called    whenever  an array type is created.
  148.      * For each new array type we create a corresponding sequence type,
  149.      * which is an unconstrained  array. Unconstrained array types have
  150.      * nature na_array, while constrained arrays have nature na_subtype.
  151.      */
  152.  
  153.     Node    index_list_node;
  154.     Tuple    tn;
  155.     Node    tnn;
  156.  
  157.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : new_array_type(array_type");
  158.  
  159.     adasem(def_node);
  160.     index_list_node = N_AST1(def_node);
  161.  
  162.     tn =  N_LIST(index_list_node);
  163.     tnn = (Node) tn[1];
  164.     if (N_KIND(tnn) == as_box)
  165.         /* Unconstrained array definition. In this case, introduce only the*/
  166.         /* unconstrained type, and ignore the actual array type.*/
  167.         new_unconstrained_array(array_type, def_node);
  168.     else
  169.         new_constrained_array(array_type, def_node);
  170. }
  171.  
  172. static void new_unconstrained_array(Symbol sequence_type, Node def_node)
  173.                                                     /*;new_unconstrained_array*/
  174. {
  175.     Node index_list_node, type_indic_node, indx_node;
  176.     Fortup    ft1;
  177.     int    i, l;
  178.     Tuple    index_list, array_info;
  179.     Symbol    comp;
  180.  
  181.     index_list_node= N_AST1(def_node);
  182.     type_indic_node = N_AST2(def_node);
  183.     /*index_list := [N_UNQ(indx_node) : indx_node in N_LIST(index_list_node)];*/
  184.     index_list = tup_new(tup_size(N_LIST(index_list_node)));
  185.     FORTUPI(indx_node=(Node), N_LIST(index_list_node), i, ft1);
  186.         index_list[i] = (char *) N_UNQ(indx_node);
  187.     ENDFORTUP(ft1);
  188.     /*??array_info := [index_list, N_UNQ(type_indic_node)];*/
  189.     array_info = tup_new(2);
  190.     array_info[1] = (char *) index_list;
  191.     comp = N_UNQ(type_indic_node);
  192.     array_info[2] = (char *) comp;
  193.     /*SYMBTAB(sequence_type) := [na_array, sequence_type, array_info];*/
  194.     NATURE(sequence_type) = na_array;
  195.     TYPE_OF(sequence_type) = sequence_type;
  196.     SIGNATURE(sequence_type) = array_info;
  197.     /*Mark the type as limited if the component type is.*/
  198.     if (is_access(comp))
  199.         misc_type_attributes(sequence_type) = 0;
  200.     else {
  201.         l= (int) private_kind(comp);
  202.         misc_type_attributes(sequence_type) = l;
  203.     }
  204.     root_type(sequence_type) = sequence_type;
  205.     initialize_representation_info(sequence_type,TAG_ARRAY);
  206.  
  207.     /* For each unconstrained array type, we introduce an instance of the
  208.      * 'aggregate' pseudo-operator for that array.
  209.      */
  210.     new_agg_or_access_agg(sequence_type);
  211. }
  212.  
  213. void new_constrained_array(Symbol array_type, Node def_node)
  214.                                                     /*;new_constrained_array*/
  215. {
  216.     char    *nam;
  217.     Fortup    ft1;
  218.     Symbol    sequence_type;
  219.     Tuple    t, index_list, array_info;
  220.     Node    index_list_node, type_indic_node, indx_node;
  221.     int    i;
  222.     char    *sequence_type_name;
  223.  
  224.     /* Construct meaningful name for anonymous parent type.*/
  225.     nam = original_name(array_type);
  226.     if (strcmp(nam , "") == 0) nam = "anonymous_array";
  227.     sequence_type_name = strjoin(nam , strjoin("\'base" , newat_str()));
  228.     sequence_type = sym_new(na_void);
  229.     dcl_put(DECLARED(scope_name), sequence_type_name, sequence_type);
  230.     SCOPE_OF(sequence_type) = SCOPE_OF(array_type);
  231.     /* emit sequence type as an anonymous type. It is used in aggregates
  232.      * that are assigned to slices, and in other unconstrained contexts.
  233.      * (This should only be needed for one dimensional arrays).
  234.      */
  235.     /*top(NEWTYPES) with:= sequence_type;*/
  236.     t = (Tuple) newtypes[tup_size(newtypes)];
  237.     t = tup_with(t, (char *) sequence_type);
  238.     newtypes[tup_size(newtypes)] = (char *) t;
  239.     new_unconstrained_array(sequence_type, def_node);
  240.  
  241.     /* Make the actual array type into a subtype of the unconstrained one*/
  242.  
  243.     index_list_node = N_AST1(def_node);
  244.     type_indic_node = N_AST2(def_node);
  245.     index_list = tup_new(tup_size(N_LIST(index_list_node)));
  246.     FORTUPI(indx_node = (Node), N_LIST(index_list_node), i, ft1);
  247.         index_list[i] = (char *) N_UNQ(indx_node);
  248.     ENDFORTUP(ft1);
  249.     /*array_info := [index_list, N_UNQ(type_indic_node)];*/
  250.     array_info = tup_new(2);
  251.     array_info[1] = (char *) index_list;
  252.     array_info[2] = (char *) N_UNQ(type_indic_node);
  253.     /*??SYMBTAB(array_type) = [na_subtype, sequence_type, array_info];*/
  254.     NATURE(array_type) = na_subtype;
  255.     TYPE_OF(array_type) = sequence_type;
  256.     SIGNATURE(array_type) = array_info;
  257.     misc_type_attributes(array_type) = misc_type_attributes(sequence_type);
  258.     root_type(array_type) = sequence_type;
  259. }
  260.  
  261. Symbol anonymous_array(Node node) /*;anonymous_array*/
  262. {
  263.     /* Process an array definition in an object or constant declaration.
  264.      * The node is an array_type node.
  265.      */
  266.  
  267.     Symbol typ;
  268.     Tuple    t;
  269.  
  270.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : anonymous_array");
  271.  
  272.     typ =    find_new(strjoin("anon", newat_str()));      /*Create  a  name for it*/
  273.     new_array_type(typ, node);    /*elaborate   definition*/
  274.     /*??top(NEWTYPES) with:= typ;*/
  275.     /* Insert into type stack */
  276.     t = (Tuple) newtypes[tup_size(newtypes)];
  277.     t = tup_with(t, (char *) typ);
  278.     newtypes[tup_size(newtypes)] = (char *) t;
  279.     return typ;
  280. }
  281.  
  282. Symbol constrain_array(Symbol type_mark, Node constraint) /*;constrain_array*/
  283. {
  284.     int    i;
  285.     Symbol    new_array;
  286.     Tuple    indices, constraint_nodes, new_indices;
  287.  
  288.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  constrain_array");
  289.  
  290.     /* Apply index constraints to array type.*/
  291.  
  292.     if (! can_constrain(type_mark)) {
  293. #ifdef ERRNUM
  294.         errmsgn(197, 195, constraint);
  295. #else
  296.         errmsg("Array type is already constrained", "3.6.1", constraint);
  297. #endif
  298.         return symbol_any;
  299.     }
  300.  
  301.     if (N_LIST_DEFINED(N_KIND(constraint)))
  302.         constraint_nodes = N_LIST(constraint);
  303.     else
  304.         constraint_nodes = (Tuple)0;
  305.     if (constraint_nodes == (Tuple)0
  306.       || tup_size(constraint_nodes) != no_dimensions(type_mark)) {
  307. #ifdef ERRNUM
  308.         id_errmsgn(198, type_mark, 195, constraint);
  309. #else
  310.         errmsg_id("Incorrect no. of index constraints for type %", type_mark,
  311.           "3.6.1", constraint);
  312. #endif
  313.         return symbol_any;
  314.     }
  315.  
  316.     if (constraint == OPT_NODE)
  317.         new_array = type_mark;
  318.     else {
  319.         /* apply constraints to each index type. */
  320.         indices = (Tuple) (index_types(type_mark) );
  321.         /* ??  new_indices = [constrain_index(indices(i), constraint_nodes(i)):
  322.          *   i in [1..#constraint_nodes]];
  323.          */
  324.         new_indices = tup_new(tup_size(constraint_nodes));
  325.         for (i = 1; i <= tup_size(constraint_nodes); i++)
  326.             new_indices[i] = (char *) constrain_index((Symbol) indices[i],
  327.               (Node) constraint_nodes[i]);
  328.     }
  329.  
  330.     new_array = anonymous_type();    /* Create  a  name for it*/
  331.     /* ??SYMBTAB(new_array):= [na_subtype, type_mark,
  332.      *     [new_indices, component_type(type_mark)]];
  333.      */
  334.     /* The signature should be in form of constraint. For now we
  335.      * will detect this case by nature na_subtype with signature
  336.      * being tuple of length two. This will be compatible with 
  337.      * uses of this signature.
  338.      */
  339.     NATURE(new_array) = na_subtype;
  340.     TYPE_OF(new_array) = type_mark;
  341.     { 
  342.         Tuple t;
  343.         t = tup_new(2);
  344.         t[1] = (char *) new_indices;
  345.         t[2] = (char *) component_type(type_mark);
  346.         SIGNATURE(new_array) = t;
  347.     }
  348.     root_type(new_array) = root_type(type_mark);
  349.     return new_array;
  350. }
  351.  
  352. Symbol make_index(Node subtype)                            /*;make_index*/
  353. {
  354.     /* Process an index  in an array declaration,  an entry family declara-
  355.      * tion, or a loop iteration. The index is given by an index declaration
  356.      * ( a 'box' ), or by a discrete range. The later can be  the name of a
  357.      * discrete type, or a subtype indication.
  358.      */
  359.  
  360.     Node    type_indic_node, constraint, lo, hi;
  361.     Symbol    typ, new_index, type_name;
  362.     Tuple    new_c;
  363.  
  364.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : make_index");
  365.  
  366.     if (N_KIND(subtype) == as_box) {
  367.         /* Unconstrained index definition. verify that the type_mark is*/
  368.         /* discrete. */
  369.         type_indic_node = N_AST1(subtype);
  370.         new_index = find_type(type_indic_node);
  371.  
  372.     }
  373.     else if (N_KIND(subtype) == as_range_attribute
  374.       || N_KIND(subtype) == as_attribute) {
  375.         /* The discrete range is given by a range attribute. Resolve as such.*/
  376.         N_KIND(subtype) = as_attribute;
  377.         find_old(subtype); 
  378.         check_type_d(subtype);
  379.         typ = N_TYPE(subtype);
  380.         new_index = anonymous_type();    /* Create  a  name for it*/
  381.         /*??SYMBTAB(new_index):=[na_subtype, typ, apply_range(subtype)];*/
  382.         NATURE(new_index) = na_subtype;
  383.         TYPE_OF(new_index) = typ;
  384.         SIGNATURE(new_index) = (Tuple) apply_range(subtype);
  385.         root_type(new_index) = root_type(typ);
  386.     }
  387.     else if (N_KIND(subtype) == as_name) {
  388.         type_indic_node = N_AST1(subtype);
  389.         new_index = find_type(type_indic_node);
  390.     }
  391.     else if (N_KIND(subtype) == as_subtype) {
  392.         /* the index is given by a subtype with a range constraint.*/
  393.  
  394.         type_indic_node = N_AST1(subtype);
  395.         constraint = N_AST2(subtype);
  396.  
  397.         lo = N_AST1(constraint);
  398.         hi = N_AST2(constraint);
  399.  
  400.         if (type_indic_node == OPT_NODE)
  401.             check_type_d(subtype);
  402.         else {            /* Type name is an identifier.*/
  403.             find_old(type_indic_node);
  404.             type_name = N_UNQ(type_indic_node);
  405.             check_type(base_type(type_name), subtype);
  406.         }
  407.         new_index = anonymous_type();    /* Create  a  name for it*/
  408.         typ     = N_TYPE(subtype);
  409.         /*SYMBTAB(new_index) = [na_subtype, typ, ['range', lo, hi]];*/
  410.         NATURE(new_index) = na_subtype;
  411.         TYPE_OF(new_index) = typ;
  412.         new_c = constraint_new(CONSTRAINT_RANGE);
  413.         numeric_constraint_low(new_c) = (char *) lo;
  414.         numeric_constraint_high(new_c) = (char *) hi;
  415.         SIGNATURE(new_index) = new_c;
  416.         root_type(new_index) = root_type(typ);
  417.     }
  418.     else {
  419. #ifdef ERRNUM
  420.         errmsgn(199, 195, subtype);
  421. #else
  422.         errmsg("Invalid expression for index definition", "3.6.1", subtype);
  423. #endif
  424.         return symbol_any;
  425.     }
  426.     /* Check that a type for the range was found, and that it is
  427.      * discrete, and generate an anonymous type for it.
  428.      */
  429.     if (noop_error)
  430.         /* Error message was emitted already. */
  431.         return  symbol_any;
  432.     else if (! is_discrete_type(new_index))     {
  433. #ifdef ERRNUM
  434.         errmsgn(200, 164, subtype);
  435. #else
  436.         errmsg("expect discrete type in discrete range", "3.3, 3.6.1", subtype);
  437. #endif
  438.         return  symbol_any;
  439.     }
  440.     return new_index;
  441. }
  442.  
  443. static Symbol constrain_index(Symbol index, Node constraint)/*;constrain_index*/
  444. {
  445.     /* Process an index constraint in a constrained array declaration.
  446.      * The constraint can be a subtype name, or a range with or without
  447.      * an explicit type mark. The index has been obtained from the signature
  448.      * of the unconstrained array.
  449.      */
  450.  
  451.     Node type_node, range_node, lo, hi;
  452.     Symbol    base_index, new_index, typ;
  453.     Tuple new_constraint;
  454.     int    nk;
  455.  
  456.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : constrain_index");
  457.  
  458.     base_index = base_type(index);
  459.     nk = N_KIND(constraint);
  460.  
  461.     if (nk == as_range_attribute) {
  462.         find_old(constraint);
  463.         N_KIND(constraint) = as_attribute;/* For resolution*/
  464.         check_type_d(constraint);
  465.  
  466.         typ = N_TYPE(constraint);
  467.         new_constraint = apply_range(constraint);
  468.  
  469.         if (! compatible_types(index, typ)) {
  470. #ifdef ERRNUM
  471.             id_errmsgn(201, index, 195, constraint);
  472. #else
  473.             errmsg_id("Invalid index constraint for %", index, "3.6.1",
  474.               constraint);
  475. #endif
  476.         }
  477.     }
  478.     else if (nk == as_subtype) {
  479.         /* The type name in the given constraint must be the same as the*/
  480.         /* original unconstrained index.*/
  481.         type_node = N_AST1(constraint);
  482.         range_node = N_AST2(constraint);
  483.         if (type_node == OPT_NODE) {
  484.             type_node = node_new(as_simple_name);
  485.             copy_span(range_node, type_node);
  486.             N_UNQ(type_node) = index;
  487.             N_AST1(constraint) = type_node;
  488.             N_AST2(constraint) = range_node;
  489.         }
  490.         else
  491.             find_old(type_node);
  492.         check_type(index, constraint);
  493.         lo = N_AST1(range_node);
  494.         hi = N_AST2(range_node);
  495.         /*new_constraint := ['range', lo, hi];*/
  496.         new_constraint = constraint_new(CONSTRAINT_RANGE);
  497.         numeric_constraint_low(new_constraint) = (char *) lo;
  498.         numeric_constraint_high(new_constraint) = (char *) hi;
  499.     }
  500.     else if (nk == as_range) {
  501.         /* In the case of allocator, the constraint appears as a range
  502.          * node, because syntactically it is just a name. Rebuild the
  503.          * node as a subtype of the index.
  504.          */
  505.  
  506.         type_node = node_new(as_simple_name);
  507.         copy_span(constraint, type_node);
  508.         N_UNQ(type_node) = index;
  509.         range_node = copy_node(constraint);
  510.         N_KIND(constraint) = as_subtype;
  511.         N_AST1(constraint)  = type_node;
  512.         N_AST2(constraint)  = range_node;
  513.  
  514.         check_type(index, constraint);
  515.         lo = N_AST1(range_node);
  516.         hi = N_AST2(range_node);
  517.         new_constraint = constraint_new(CONSTRAINT_RANGE);
  518.         numeric_constraint_low(new_constraint) = (char *) lo;
  519.         numeric_constraint_high(new_constraint) = (char *) hi;
  520.     }
  521.     else if (nk == as_name) {
  522.         type_node = N_AST1(constraint);
  523.         if (N_KIND(type_node) == as_attribute) {
  524.             find_old(constraint);
  525.             check_type(symbol_discrete_type, constraint);
  526.             typ = N_TYPE(constraint);
  527.             new_constraint = apply_range(constraint);
  528.             if (! compatible_types(index, typ) ) {
  529. #ifdef ERRNUM
  530.                 id_errmsgn(201, index, 195, constraint);
  531. #else
  532.                 errmsg_id("Invalid index constraint for %", index, "3.6.1",
  533.                   constraint);
  534. #endif
  535.             }
  536.         }
  537.         else {
  538.             find_old(type_node);
  539.             new_index = N_UNQ(type_node);
  540.             if (! compatible_types(index, new_index) ) {
  541. #ifdef ERRNUM
  542.                 id_errmsgn(201, index, 195, constraint);
  543. #else
  544.                 errmsg_id("Invalid index constraint for %", index, "3.6.1",
  545.                   constraint);
  546. #endif
  547.             }
  548.         }
  549.     }
  550.     else {
  551. #ifdef ERRNUM
  552.         id_errmsgn(201, index, 195, constraint);
  553. #else
  554.         errmsg_id("Invalid index constraint for %", index, "3.6.1", constraint);
  555. #endif
  556.         new_index = base_index;
  557.     }
  558.  
  559.     if (N_KIND(constraint) != as_name ) {
  560.         /* create anonymous type for index.*/
  561.         new_index = anonymous_type();
  562.         /*??SYMBTAB(new_index) := [na_subtype, index, new_constraint];*/
  563.         NATURE(new_index) = na_subtype;
  564.         TYPE_OF(new_index) = index;
  565.         SIGNATURE(new_index) = (Tuple) new_constraint;
  566.         root_type(new_index) = root_type(index);
  567.     }
  568.     return new_index;
  569. }
  570.  
  571. void record_decl(Symbol type_name, Node opt_disc, Node type_def)/*;record_decl*/
  572. {
  573.     /* Records constitute  a scope    for  the  component declarations within.
  574.      * The    scope is created prior to  the processing of these declarations.
  575.      * Discriminants  are  processed first, so  that  they are visible when
  576.      * processing the  other components. After the    discriminants have  been
  577.      * processed we set the nature of the type to na_record.
  578.      *
  579.      * If  an  incomplete or private  type declaration  was already given for
  580.      * the type, then this    scope already exists, and  the discriminants have
  581.      * been declared within. We must verify that the full declaration matches
  582.      * the    incomplete one.
  583.      */
  584.  
  585.     Node comp_list_node, comp_dec_node, variant_node;
  586.     Symbol n;
  587.     Fordeclared    div;
  588.     Symbol    comp;
  589.     int    l;
  590.     char    *str;
  591.     Tuple    rectup;
  592.  
  593.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : record_decl");
  594.  
  595.     if (record_declarations(type_name) == (Tuple)0)
  596.         process_discr(type_name, opt_disc);
  597.     else
  598.         newscope(type_name);
  599.     NATURE(type_name) = na_record;
  600.     TYPE_OF(type_name) = type_name;
  601.     root_type(type_name) = type_name;
  602.  
  603.     /* Now process remaining field declarations.*/
  604.     adasem(type_def);
  605.     comp_list_node = N_AST1(type_def);
  606.  
  607.     comp_dec_node = N_AST1(comp_list_node);
  608.     variant_node = N_AST2(comp_list_node);
  609.     /* use indices in next few assignments since cannot use macros
  610.      * invariant_part, variant_part and declared_components on left hand side 
  611.      */
  612.     rectup = SIGNATURE(type_name);
  613.     rectup[1] = (char *) comp_dec_node; /* invariant_part */
  614.     /*invariant_part(type_name) = (char *) comp_dec_node;*/
  615.     /*variant_part(type_name) = (char *) variant_node;*/
  616.     rectup[2] = (char *) variant_node;
  617.  
  618.     /*declared_components(type_name) = (char *) DECLARED(scope_name);*/
  619.     rectup[4] =  (char *) DECLARED(scope_name);
  620.     misc_type_attributes(type_name) = 0;
  621. #ifdef TBSL
  622.     -- in SETL, following qualified by 'if exists'. review this  ds 6-jan-85
  623. #endif
  624.     FORDECLARED(str, comp, (Declaredmap)DECLARED(scope_name), div)
  625.         l = private_kind(TYPE_OF(comp));
  626.         misc_type_attributes(type_name) = 
  627.           (int) misc_type_attributes(type_name) | l;
  628.         if  (l != 0) 
  629.             break;
  630.     ENDFORDECLARED(div)
  631.  
  632.     /* The nature of the record components is given as na_field while the
  633.      * record is being processed, in order to catch invalid dependencies
  634.      * among component declarations. Reset the nature  of each to 'obj'
  635.      * (except for discriminants of course).
  636.      */
  637.  
  638.     FORDECLARED(str, n, (Declaredmap)(DECLARED(scope_name)), div)
  639.         if (NATURE(n) == na_field)
  640.             NATURE(n) = na_obj;
  641.         else if (NATURE(n) == na_discriminant) {
  642.             /* constant folding of default values of discriminants is
  643.              * delayed until after conformance checks
  644.              */
  645.             eval_static((Node)default_expr(n));
  646.         }
  647.     ENDFORDECLARED(div)
  648.     popscope();            /* Exit record scope.*/
  649.  
  650.     /* For each record type we create an aggregate of the corresponding
  651.      * type.
  652.      */
  653.      initialize_representation_info(type_name,TAG_RECORD);
  654. #ifdef TBSL
  655.     not_chosen_put(type_name, (Symbol)0);
  656. #endif
  657.  
  658.     current_node = type_def;
  659.     new_agg_or_access_agg(type_name);
  660. }
  661.  
  662. void process_discr(Symbol type_name, Node opt_disc) /*;process_discr*/
  663. {
  664.     /* Process discriminants, or reprocess them in a full type declaration.
  665.      * Introduce the record scope. It is exited after the call, in type_decl
  666.      * or record decl, or private_decl.
  667.      */
  668.  
  669.     Tuple disc_names;
  670.     Node    discr_node, id_list_node, id_node;
  671.     Fortup    ft1, ft2;
  672.     int    i, has_default;
  673.     Tuple    rectup;
  674.  
  675.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  process_discr");
  676.  
  677.     newscope(type_name);
  678.  
  679.     record_declarations(type_name) = tup_new(5);
  680.     discr_decl(opt_disc);
  681.     /*discr_decl_tree(type_name) = (char *) opt_disc;*/
  682.     /* use index since cannot use discr_decl_tree macro on left     ds 31 dec 84*/
  683.     rectup = SIGNATURE(type_name);
  684.     rectup[5] = (char *) opt_disc;
  685.     if (opt_disc != OPT_NODE) {
  686.         /* add 'constrained' bit as additional discriminant in front.*/
  687.         disc_names = tup_new1((char *)symbol_constrained);
  688.  
  689.         FORTUP(discr_node =(Node), N_LIST(opt_disc), ft1 );
  690.             id_list_node = N_AST1(discr_node);
  691.             FORTUP(id_node =(Node), N_LIST(id_list_node), ft2);
  692.                 disc_names = tup_with(disc_names, (char *) N_UNQ(id_node));
  693.             ENDFORTUP(ft2);
  694.         ENDFORTUP(ft1);
  695.  
  696.         /* Check that all discriminants have default values, or none.*/
  697.         /* Omit constrained bit from this test.                      */
  698.         has_default = ((Node)default_expr((Symbol)disc_names[2]) != OPT_NODE);
  699.  
  700.         for (i = 3; i <= tup_size(disc_names); i++) {
  701.             if (((Node)(default_expr((Symbol)disc_names[i])) != OPT_NODE)
  702.               != has_default) {
  703. #ifdef ERRNUM
  704.                 errmsgn(202, 150, opt_disc);
  705. #else
  706.                 errmsg(
  707.                   "Incomplete specification of default vals for discriminants",
  708.                   "3.7.1", opt_disc);
  709. #endif
  710.             }
  711.         }
  712.     }
  713.     else disc_names = tup_new(0);
  714.     /*discriminant_list(type_name) = (char *) disc_names;*/
  715.     rectup = SIGNATURE(type_name);
  716.     rectup[3] = (char *) disc_names;
  717.     /* Make names of discriminants visible at this point, because they may
  718.      * be used in constraints to other components of the current record type.
  719.      */
  720.     /*declared_components(type_name) = DECLARED(scope_name);*/
  721.     rectup[4] = (char *) DECLARED(scope_name);
  722. }
  723.  
  724. static void discr_decl(Node discr_list_node) /*;discr_decl*/
  725. {
  726.     /* Process discriminant declarations. Discriminants  are processed  like
  727.      * variable declarations, except that the type of a discriminant must be
  728.      * discrete,  and  the    nature    of  a  discriminant is, naturally enough
  729.      * na_discriminant. This insures that discriminants cannot appear on the
  730.      * left of an assignment, nor in expressions.
  731.      */
  732.  
  733.     Node discr_node, id_list_node, type_node, init_node, id_node;
  734.     Tuple id_nodes, nam_list;
  735.     Symbol type_mark, n;
  736.     int    i;
  737.     Fortup ft1, ft2;
  738.     Node    i_node, tmpnode, type_copy;
  739.  
  740.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  discr_decl");
  741.  
  742.     FORTUP(discr_node =(Node), N_LIST(discr_list_node), ft1);
  743.         id_list_node = N_AST1(discr_node);
  744.         type_node = N_AST2(discr_node);
  745.         init_node = N_AST3(discr_node);
  746.         id_nodes = N_LIST(id_list_node);
  747.         current_node = id_list_node;
  748.         nam_list = tup_new(tup_size(id_nodes));
  749.         FORTUPI(id_node=(Node), id_nodes, i, ft2);
  750.             nam_list[i] = (char *) find_new(N_VAL(id_node));
  751.         ENDFORTUP(ft2);
  752.         /* save original type_node for later conformance checks */
  753.         type_copy = copy_tree(type_node);
  754.         find_type(type_copy);
  755.         type_mark = N_UNQ(type_copy);
  756.  
  757.         if (! is_discrete_type(type_mark) ) {
  758. #ifdef ERRNUM
  759.             errmsgn(203, 150, type_node);
  760. #else
  761.             errmsg("Discriminant must have discrete type", "3.7.1", type_node);
  762. #endif
  763.             type_mark = symbol_any;
  764.         }
  765.  
  766.         if (init_node != OPT_NODE ) {
  767.             /* type check, but do not perform constant folding, for later
  768.               * conformance checks
  769.               */
  770.             i_node = copy_tree(init_node);
  771.             adasem(i_node);
  772.             normalize(type_mark, i_node);
  773.         }
  774.         else i_node = init_node;
  775.  
  776.         FORTUP(n =(Symbol), nam_list, ft2);
  777.             NATURE(n) = na_discriminant;
  778.             TYPE_OF(n) = type_mark;
  779.             SIGNATURE(n) = (Tuple) i_node;
  780.         ENDFORTUP(ft2);
  781.         for     (i = 1; i <= tup_size(id_nodes); i++) {
  782.             tmpnode = (Node) id_nodes[i];
  783.             N_UNQ(tmpnode) = (Symbol) nam_list[i];
  784.         }
  785.     ENDFORTUP(ft1);
  786. }
  787.  
  788. void discr_redecl(Symbol type_name, Node discr_list)    /*;discr_redecl */
  789. {
  790.     /* Verify conformance of discriminant part on redeclarations of types. */
  791.  
  792.     Node  node, old_node, old_discr_list, id_list, type_node, init_node;
  793.     Node  old_type_node, old_id_list, old_init_node;
  794.     Tuple discr_tup, old_discr_tup;
  795.     Symbol  discr;
  796.     int  i;
  797.  
  798.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  discr_redecl");
  799.  
  800.     old_discr_list = (Node) discr_decl_tree(type_name);
  801.  
  802.     if (!conform(discr_list, old_discr_list)) {
  803.         conformance_error(discr_list != OPT_NODE ? discr_list : current_node);
  804.         return;
  805.     }
  806.  
  807.     discr_tup = N_LIST(discr_list);
  808.     old_discr_tup = N_LIST(old_discr_list);
  809.     for (i = 1; i <= tup_size(old_discr_tup); i++) {
  810.         node = (Node) discr_tup[i];
  811.         old_node = (Node) old_discr_tup[i];
  812.         /* Pick a representatitive discriminant from current id list. */
  813.         old_id_list = N_AST1(old_node);
  814.         id_list = N_AST1(node);
  815.         discr = N_UNQ((Node)N_LIST(old_id_list)[1]);
  816.  
  817.         old_type_node = N_AST2(old_node);
  818.         type_node = N_AST2(node);
  819.         init_node = N_AST3(node);
  820.         old_init_node = N_AST3(old_node);
  821.         find_type(type_node);
  822.         if (N_UNQ(type_node) != TYPE_OF(discr))  {
  823.             conformance_error(type_node);
  824.             return;
  825.         } /* end if; */
  826.  
  827.         if (init_node != OPT_NODE) {
  828.             adasem(init_node);
  829.             normalize(N_UNQ(type_node), init_node);
  830.         }
  831.         /* Verify that the default values are the same.  */
  832.         if (!same_expn(init_node, (Node)default_expr(discr)) ) {
  833.             conformance_error(init_node == OPT_NODE ? node : init_node);
  834.             return;
  835.         }
  836.     }
  837. }
  838.  
  839. int same_expn(Node exp1, Node exp2)                     /*;same_expn */
  840. {
  841.     /* verify that two resolved expression trees designate the same entity,
  842.      * or evaluate to the same.
  843.      */
  844.  
  845.     int i, nk;
  846.     Tuple l1, l2;
  847.  
  848.     if (N_KIND(exp1) != N_KIND(exp2))
  849.         return FALSE;
  850.  
  851.     nk = N_KIND(exp1);
  852.     switch (nk) {
  853.     case (as_simple_name):
  854.         return (N_UNQ(exp1) == N_UNQ(exp2));
  855.     case (as_ivalue):
  856.         return const_eq((Const)N_VAL(exp1), (Const)N_VAL(exp2));
  857.     default:
  858.         if (N_AST1_DEFINED(nk) && (N_AST1(exp1) != (Node)0)) {
  859.             if (!same_expn(N_AST1(exp1), N_AST1(exp2)))
  860.                 return FALSE;
  861.             if (N_AST2_DEFINED(nk) && N_AST2(exp1) != (Node)0) {
  862.                 if (!same_expn(N_AST2(exp1), N_AST2(exp2)))
  863.                     return FALSE;
  864.                 if (N_AST3_DEFINED(nk) && N_AST3(exp1) != (Node)0) {
  865.                     if (!same_expn(N_AST3(exp1), N_AST3(exp2)))
  866.                         return FALSE;
  867.                     if (N_AST4_DEFINED(nk) && N_AST4(exp1) != (Node)0) {
  868.                         if (!same_expn(N_AST4(exp1), N_AST4(exp2)))
  869.                             return FALSE;
  870.                     }
  871.                 }
  872.             }
  873.         }
  874.         if (N_LIST_DEFINED(nk))
  875.             l1 = N_LIST(exp1);
  876.         else
  877.             l1 = (Tuple)0;
  878.         if (l1  != (Tuple)0 ) {
  879.             if (N_LIST_DEFINED(N_KIND(exp2)))
  880.                 l2 = N_LIST(exp2);
  881.             else
  882.                 l2 = (Tuple) 0;
  883.             if (l2 == (Tuple)0 || tup_size(l1) != tup_size(l2))
  884.                 return FALSE;
  885.             for (i = 1; i<= tup_size(l1); i++) {
  886.                 if (!same_expn((Node)l1[i], (Node)l2[i]))
  887.                     return FALSE;
  888.             }
  889.         }
  890.         return TRUE;        /* AST and LIST match. */
  891.     }
  892. }
  893.  
  894. void conformance_error(Node node)                 /*;conformance_error */
  895. {
  896. #ifdef ERRNUM
  897.     errmsgn(204, 205, node);
  898. #else
  899.     errmsg("non conformance to previous declaration", "6.3.1", node);
  900. #endif
  901. }
  902.  
  903. #ifdef TBSN
  904. Tuple bind_discr(Tuple discr_list)  /*;bind_discr*/
  905. {
  906.     /* The conformance rules  for  discriminant specifications require  the
  907.      * equality of the corresponding trees after name resolution and before
  908.      * constant  folding. (In fact, overload  resolution  may be  needed if
  909.      * function calls appear in the default expressions).
  910.      */
  911.     Tuple    t1, t2;
  912.     Fortup    ft1;
  913.     Tuple    res;
  914.     int    i;
  915.  
  916.     res = tup_new(tup_size(discr_list));
  917.     FORTUPI(t1=(Tuple), discr_list, i, ft1);
  918.         t2 = tup_new(4);
  919.         t2[1] = t1[1];
  920.         t2[2] = t1[2];
  921.         t2[3] = t1[3];
  922.         t2[4] = (char *) bind_names(t1[4]);
  923.         res[i] = (char *) t2;
  924.     ENDFORTUP(ft1);
  925.     return res;
  926. }
  927. #endif
  928.  
  929. void comp_decl(Node field_node) /*;comp_decl*/
  930. {
  931.     /* Process record component declaration.
  932.      * Verify that the type is a constrained one, or that default values
  933.      * exist for the discriminants of the type.
  934.      */
  935.  
  936.     Node id_list_node, type_indic_node, expn_node, id_node;
  937.     Tuple id_nodes, nam_list;
  938.     Symbol type_mark, t_m, n;
  939.     int        i;
  940.     Fortup    ft1;
  941.  
  942.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  comp_decl");
  943.  
  944.     id_list_node = N_AST1(field_node);
  945.     type_indic_node = N_AST2(field_node);
  946.     expn_node = N_AST3(field_node);
  947.  
  948.     id_nodes = N_LIST(id_list_node);
  949.     nam_list = tup_new(tup_size(id_nodes));
  950.     FORTUPI(id_node=(Node), id_nodes, i, ft1);
  951.         nam_list[i] = (char *) find_new(N_VAL(id_node));
  952.     ENDFORTUP(ft1);
  953.  
  954.     adasem(type_indic_node);
  955.     type_mark = promote_subtype(make_subtype(type_indic_node));
  956.     N_UNQ(type_indic_node) = type_mark;
  957.     check_fully_declared2(type_mark);
  958.     adasem(expn_node);
  959.  
  960.     /* Type-check the initial value, if provided.*/
  961.  
  962.     if (expn_node != OPT_NODE) {
  963.         t_m = check_init(type_indic_node, expn_node);
  964.         /* check_type(type_mark, expn_node); */
  965.     }
  966.  
  967.     /* Try to catch self-reference within a record type (a common mistake).*/
  968.     if (in_open_scopes(type_mark )) {
  969. #ifdef ERRNUM
  970.         nval_errmsgn(206, type_indic_node, 207, type_indic_node);
  971. #else
  972.         errmsg_nval("Invalid self-reference in definition of %",
  973.           type_indic_node, "3.1", type_indic_node);
  974. #endif
  975.     }
  976.     if (is_unconstrained(type_mark)) {
  977. #ifdef ERRNUM
  978.         nat_errmsgn(208, type_mark, 132, type_indic_node);
  979. #else
  980.         errmsg_nat("Unconstrained % in component declaration", type_mark,
  981.           "3.6.1, 3.7.2", type_indic_node);
  982. #endif
  983.     }
  984.  
  985.     FORTUP(n=(Symbol), nam_list, ft1);
  986.         NATURE(n) = na_field;
  987.         TYPE_OF(n) = type_mark;
  988.         SIGNATURE(n) = (Tuple) expn_node;
  989.     ENDFORTUP(ft1);
  990.  
  991.     for (i = 1; i <= tup_size(id_nodes); i++) {
  992.         Node tmp = (Node) id_nodes[i];
  993.         N_UNQ(tmp) = (Symbol) nam_list[i];
  994.     }
  995. }
  996.  
  997. Symbol constrain_record(Symbol type_mark, Node constraint) /*;constrain_record*/
  998. {
  999.     /* Process discriminant constraints of record type.
  1000.      * Verify that values have been provided for all discriminants, that
  1001.      * the original type is unconstrained, and that the types of the
  1002.      * supplied expressions match the discriminant types.
  1003.      */
  1004.  
  1005.     Symbol    d_name, typ;
  1006.     Tuple d_list;
  1007.     Tuple c_list, discr_map;
  1008.     char *d_id;
  1009.     Tuple d_seen;
  1010.     /* TBSL: d_seen should be freed before return    ds 6-jan-85 */
  1011.     Declaredmap comps;
  1012.     Tuple constraint_list;
  1013.     Node  ct, choice_list_node, choice_node, expn, name, nam, comp_assoc;
  1014.     int i, first_named, exists, j, k, d_list_size;
  1015.     Fortup    ft1, ft2;
  1016.     Tuple    dconstraint;
  1017.  
  1018.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : constrain_record");
  1019.  
  1020.     if (! is_record(type_mark)) {
  1021. #ifdef ERRNUM
  1022.         errmsgn(209, 210, constraint);
  1023. #else
  1024.         errmsg("Invalid type for constraint", "3.3, 3.7.2", constraint);
  1025. #endif
  1026.         return symbol_any;
  1027.     }
  1028.     d_list = (Tuple) discriminant_list(type_mark);
  1029.  
  1030.     if(d_list == (Tuple)0 || tup_size(d_list) == 0) {
  1031. #ifdef ERRNUM
  1032.         errmsgn(211, 212, constraint);
  1033. #else
  1034.         errmsg("Invalid constraint: Record type has no discriminant",
  1035.           "3.7.1, 3.7.2", constraint);
  1036. #endif
  1037.         return symbol_any;
  1038.     }
  1039.  
  1040.     d_seen = tup_new(0);        /*To verify that all discriminants were*/
  1041.     /* given values.*/
  1042.  
  1043.     constraint_list = N_LIST(constraint);
  1044.  
  1045.     /* Look for named associations in discriminant constraint list.*/
  1046.  
  1047.     exists = FALSE;
  1048.     FORTUPI(ct = (Node), constraint_list, i, ft1);
  1049.         if  (N_KIND(ct) == as_choice_list) {
  1050.             exists = TRUE;
  1051.             break;
  1052.         }
  1053.     ENDFORTUP(ft1);
  1054.     if  (exists) {
  1055.         first_named = i;
  1056.         exists = FALSE;
  1057.         for (j=i+1; j <= tup_size(constraint_list); j++) {
  1058.             nam = (Node) constraint_list[j];
  1059.             if ( N_KIND(nam) != as_choice_list ) {
  1060.                 exists = TRUE;
  1061.                 break;
  1062.             }
  1063.         }
  1064.         if (exists) {
  1065. #ifdef ERRNUM
  1066.             errmsgn(213, 214, nam);
  1067. #else
  1068.             errmsg("Positional associations after named ones", "3.7.2", nam);
  1069. #endif
  1070.             return symbol_any;
  1071.         }
  1072.     }
  1073.     else
  1074.         first_named = tup_size(constraint_list) + 1;
  1075.     d_list_size = tup_size(d_list);
  1076.     discr_map = tup_new(0);
  1077.  
  1078.     /* The constrained bit is treated like a discriminant, and the system
  1079.      * provides the initial constraint for it. This may be reset in the
  1080.      * expander. 
  1081.      */
  1082.     discr_map = discr_map_put(discr_map, symbol_constrained,
  1083.       new_ivalue_node(int_const(TRUE), symbol_boolean));
  1084.     d_seen = tup_with(d_seen, (char *) symbol_constrained);
  1085.  
  1086.     for (i = 1; i<first_named; i++) {
  1087.         if (i+1 > d_list_size) {    /* Exhausted discriminant list*/
  1088. #ifdef ERRNUM
  1089.             errmsgn(215, 214, current_node);
  1090. #else
  1091.             errmsg("Too many constraints for record type", "3.7.2",
  1092.               current_node);
  1093. #endif
  1094.             return symbol_any;
  1095.         }
  1096.         d_name = (Symbol) d_list[i+1];
  1097.         constraint = (Node) constraint_list[i];
  1098.         check_type(TYPE_OF(d_name), constraint);
  1099.         check_discriminant(constraint);
  1100.  
  1101.         if (N_TYPE(constraint) == symbol_any)  /* Type error occurred.*/
  1102.             ;
  1103.         else
  1104.             discr_map = discr_map_put(discr_map, d_name, constraint );
  1105.         if (!tup_mem( (char *) d_name, d_seen))
  1106.             d_seen = tup_with(d_seen, (char *)  d_name);
  1107.     }
  1108.  
  1109.     /* recall that in SETL
  1110.      * named_constraint = constraint_list(first_named..);
  1111.      * so can replace comp_assoc in named_constraint by following
  1112.      */
  1113.     for (j=first_named; j <= tup_size(constraint_list); j++) {
  1114.         comp_assoc = (Node) constraint_list[j];
  1115.         choice_list_node = N_AST1(comp_assoc);
  1116.         expn = N_AST2(comp_assoc);
  1117.         c_list = tup_new(0);    /* to collect names in this association.*/
  1118.  
  1119.         FORTUP(choice_node=(Node), N_LIST(choice_list_node), ft2);
  1120.             name = N_AST1(choice_node);
  1121.             if (N_KIND(choice_node) != as_choice_unresolved ) {
  1122. #ifdef ERRNUM
  1123.                 l_errmsgn(216, 217, 212, choice_node);
  1124. #else
  1125.                 errmsg_l("Expect discriminant names only in discriminant",
  1126.                   " constraint", "3.7.1, 3.7.2", choice_node);
  1127. #endif
  1128.                 return    symbol_any;
  1129.             }
  1130.  
  1131.             d_id = N_VAL(name);
  1132.             comps = (Declaredmap) declared_components(type_mark);
  1133.             if (d_id == (char *)0  || (comps == (Declaredmap) 0)
  1134.               || (d_name = dcl_get(comps, d_id)) == (Symbol) 0
  1135.               || NATURE(d_name) != na_discriminant) {
  1136. #ifdef ERRNUM
  1137.                 errmsgn(218, 219, choice_node);
  1138. #else
  1139.                 errmsg("Invalid discriminant name in discriminant constraint",
  1140.                   "3.7. 3.7.2", choice_node);
  1141. #endif
  1142.                 return symbol_any;
  1143.             }
  1144.             if (tup_mem((char *) d_name, d_seen)) {
  1145. #ifdef ERRNUM
  1146.                 str_errmsgn(220, d_id, 212, choice_node);
  1147. #else
  1148.                 errmsg_str("Duplicate constraint for discriminant %",
  1149.                   d_id, "3.7.1, 3.7.2", choice_node);
  1150. #endif
  1151.             }
  1152.             else {
  1153.                 c_list = tup_with(c_list, (char *) d_name);
  1154.                 if (!tup_mem((char *) d_name, d_seen))
  1155.                     d_seen = tup_with(d_seen, (char *) d_name);
  1156.                 TO_XREF(d_name);
  1157.  
  1158.                 if (tup_size(c_list) == 1) {
  1159.                     /* need to resolve it only for the first in list */
  1160.                     check_type(TYPE_OF(d_name), expn);
  1161.                     check_discriminant(expn);
  1162.                 }
  1163.             }
  1164.         ENDFORTUP(ft2);
  1165.         discr_map = discr_map_put(discr_map, (Symbol) c_list[1], expn);
  1166.  
  1167.         for (k = 2; k <= tup_size(c_list); k++) {
  1168.             discr_map = discr_map_put(discr_map, (Symbol) c_list[k],
  1169.               copy_tree(expn));
  1170.             if (base_type(TYPE_OF((Symbol)c_list[k]))
  1171.               != base_type(TYPE_OF((Symbol)c_list[1]))) {
  1172. #ifdef ERRNUM
  1173.                 errmsgn(221, 222, comp_assoc);
  1174. #else
  1175.                 errmsg("discriminants in named association must have same type",
  1176.                   "3.7.2(4)", comp_assoc);
  1177. #endif
  1178.             }
  1179.         }
  1180.     }
  1181.     if (tup_size(d_seen) == tup_size(d_list)) { /* All discriminants were ok.*/
  1182.         typ = anonymous_type();         /* Create a name for it*/
  1183.         NATURE(typ) = na_subtype;
  1184.         TYPE_OF(typ) = type_mark;
  1185.         dconstraint = constraint_new(CONSTRAINT_DISCR);
  1186.         numeric_constraint_discr(dconstraint) = (char *) discr_map;
  1187.         SIGNATURE(typ) = (Tuple) dconstraint;
  1188.         root_type(typ) = type_mark;
  1189.         not_chosen_put(type_mark, typ);
  1190.         type_mark = typ;
  1191.     }
  1192.     else {
  1193. #ifdef ERRNUM
  1194.         errmsgn(223, 214, constraint);
  1195. #else
  1196.         errmsg("Missing constraints for discriminants", "3.7.2", constraint);
  1197. #endif
  1198.     }
  1199.     /* TBSL: free d_seen if defined        ds 6-jan-85*/
  1200.     return type_mark;
  1201. }
  1202.  
  1203. int check_discriminant(Node expn) /*;check_discriminant*/
  1204. {
  1205.     /* Verify that when a discriminant appears in an index constraint or a
  1206.      * discriminant constraint, it appears by itself and not as part of a
  1207.      * larger expression. The check is made after type checking, in which case
  1208.      * a constraint check may be applied on the node. The expression being
  1209.      * constrained may be a valid discriminant reference itself.
  1210.      */
  1211.  
  1212.     int    i, nk;
  1213.     Node    sub_expn;
  1214.     Fortup    ft;
  1215.  
  1216.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_discriminant");
  1217.  
  1218.     if (NATURE(scope_name) != na_record) return FALSE;
  1219.     if (N_KIND(expn) == as_simple_name) return FALSE;
  1220.  
  1221.     if ( (N_KIND(expn) == as_discr_ref) || (N_KIND(expn) == as_qual_range
  1222.       && N_KIND(N_AST1(expn)) == as_discr_ref))
  1223.         return TRUE;
  1224.     /* TBSN: check recoding of following loop over all AST subnodes*/
  1225.     nk = N_KIND(expn);
  1226.     for (i = 1; i <= 4; i++) {
  1227.         sub_expn = (Node)0;
  1228.         if (i == 1)
  1229.             if (N_AST1_DEFINED(nk)) sub_expn = N_AST1(expn);
  1230.         else if (i == 2)
  1231.             if (N_AST2_DEFINED(nk)) sub_expn = N_AST2(expn);
  1232.         else if (i == 3)
  1233.             if (N_AST3_DEFINED(nk)) sub_expn = N_AST3(expn);
  1234.         else if (i == 4)
  1235.             if (N_AST4_DEFINED(nk)) sub_expn = N_AST4(expn);
  1236.         if (sub_expn != (Node)0 && check_discriminant(sub_expn)) {
  1237. #ifdef ERRNUM
  1238.             l_errmsgn(224, 225, 150, expn);
  1239. #else
  1240.             errmsg_l("a discriminant appearing in a subtype indication ",
  1241.               "must appear by itself", "3.7.1", expn);
  1242. #endif
  1243.             return FALSE;        /*No need to propagate error.*/
  1244.         }
  1245.     }
  1246.     /* must also search through N_LIST */
  1247.     if (N_LIST_DEFINED(nk) && N_LIST(expn) != (Tuple)0) {
  1248.         FORTUP(sub_expn=(Node), N_LIST(expn), ft);
  1249.             if (check_discriminant(sub_expn)) {
  1250. #ifdef ERRNUM
  1251.                 l_errmsgn(224, 225, 150, expn);
  1252. #else
  1253.                 errmsg_l("a discriminant appearing in a subtype indication ",
  1254.                   "must appear by itself", "3.7.1", expn);
  1255. #endif
  1256.                 return FALSE;        /*No need to propagate error.*/
  1257.             }
  1258.         ENDFORTUP(ft);
  1259.     }
  1260.     return FALSE;
  1261. }
  1262.  
  1263. void variant_decl(Node node)                                /*;variant_decl*/
  1264. {
  1265.     Node id_node, variant_list;
  1266.     Symbol    discr_name, dtyp;
  1267.  
  1268.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  variant_decl");
  1269.  
  1270.     id_node = N_AST1(node);
  1271.     variant_list = N_AST2(node);
  1272.  
  1273.     find_old(id_node);
  1274.     discr_name = N_UNQ(id_node);
  1275.     if (NATURE(discr_name) != na_discriminant) {
  1276. #ifdef ERRNUM
  1277.         errmsgn(226, 227, id_node);
  1278. #else
  1279.         errmsg("Invalid discriminant name in variant part", "3.7.1, 3.7.3", id_node);
  1280. #endif
  1281.         return;
  1282.     }
  1283.     else if ((dtyp = TYPE_OF(discr_name)) == (Symbol)0 )
  1284.         return;
  1285.     else
  1286.         process_case(dtyp, variant_list);
  1287. }
  1288.  
  1289. void incomplete_decl(Node node)                                /*;incomplete_decl*/
  1290. {
  1291.     Node    id_node, discr_list_node;
  1292.     char    *id;
  1293.     Symbol    name, old_name;
  1294.  
  1295.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  incomplete_decl");
  1296.  
  1297.     /* Process  an    incomplete  declaration. The  identifier  must    not  have
  1298.      * been declared already in the scope. However, an incomplete declaration
  1299.      * may    appear in  the private part of a package, for a private type that
  1300.      * has already been  declared. In  this case,  the discriminants (if any)
  1301.      * must match.
  1302.      */
  1303.  
  1304.     id_node = N_AST1(node);
  1305.     discr_list_node = N_AST2(node);
  1306.  
  1307.     sem_list(discr_list_node);
  1308.     id = N_VAL(id_node);
  1309.     old_name = dcl_get(DECLARED(scope_name), id);
  1310.     if (old_name == (Symbol)0 ) {
  1311.         name = find_new(id);
  1312.         N_UNQ(id_node) = name;
  1313.         TYPE_OF(name) = symbol_incomplete;
  1314.         root_type(name) = name;
  1315.         process_discr(name, discr_list_node);
  1316.         NATURE(name) = na_type;
  1317.         popscope();
  1318.     }
  1319.     else if (NATURE(scope_name) == na_private_part
  1320.       && (TYPE_OF(old_name) == symbol_private
  1321.       ||  TYPE_OF(old_name) == symbol_limited_private))
  1322.     {
  1323.         /* redeclaration of private type in private part.*/
  1324.         process_discr(old_name, discr_list_node);
  1325.         N_UNQ(id_node) = old_name;
  1326.         popscope();
  1327.     }
  1328.     else {
  1329. #ifdef ERRNUM
  1330.         str_errmsgn(230, id, 231, id_node);
  1331. #else
  1332.         errmsg_str("invalid redeclaration of %", id, "3.8, 8.2", id_node);
  1333. #endif
  1334.     }
  1335. }
  1336.  
  1337. void check_incomplete(Symbol type_mark)                      /*;check_incomplete*/
  1338. {
  1339.     /* Called to verify that an incomplete type is not used prematurely.*/
  1340.  
  1341.     if (TYPE_OF(base_type(type_mark)) == symbol_incomplete) {
  1342. #ifdef ERRNUM
  1343.         id_errmsgn(158, type_mark, 5, current_node);
  1344. #else
  1345.         errmsg_id("Invalid use of type % before its full declaration",
  1346.           type_mark, "3.8.1", current_node);
  1347. #endif
  1348.     }
  1349. }
  1350.  
  1351. void declarative_part(Node node)                        /*;declarative_part*/
  1352. {
  1353.     /* Clean up list of declarations and generate nodes for anonymous types
  1354.      * that are created when elaborating subtype indications, etc.
  1355.      */
  1356.  
  1357.     Tuple    decl_nodes, type_list, anon_nodes, tup, id_list;
  1358.     Node    d, type_def, nam, component_list, invariant_node, init_node;
  1359.     Node    constraint, nod, id_node, subtype_indic, id_list_node;
  1360.     Fortup    ft1, ft2, ft3; 
  1361.     int        reformat;
  1362.     Node    type_indic_node, pnode, new_decl, a;
  1363.     Node    ancestor_node, decl_node, init;
  1364.  
  1365.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  declarative_part");
  1366.  
  1367.     decl_nodes = tup_new(0);
  1368.  
  1369.     FORTUP(d = (Node), N_LIST(node), ft1);
  1370.         if (N_KIND(d) == as_line_no) {     /* keep it for debugging */
  1371.             decl_nodes = tup_with(decl_nodes, (char *) d);
  1372.             continue;
  1373.         }
  1374.  
  1375.         /* For object and constant declarations create distinct declaration
  1376.          * nodes for each item in the id_list except in the case where the 
  1377.          * subtype indication is just a type mark. Complete constant decls.
  1378.          * are always expanded.
  1379.          */
  1380.         id_list_node    = N_AST1(d);
  1381.         type_indic_node = N_AST2(d);
  1382.         init_node       = N_AST3(d);
  1383.  
  1384.         if (N_KIND(d) == as_const_decl) reformat = TRUE;
  1385.  
  1386.         else if (N_KIND(d) == as_obj_decl ) {
  1387.             if (N_KIND(type_indic_node) == as_subtype_indic ) {
  1388.                 /* if subtype indication carries explicit constraint,
  1389.                  * must elaborate each declaration separately.
  1390.                    * (This latter is a little bit to strict.
  1391.                  * In a declaration like :
  1392.                    * type ARR is array (integer range <>) of integer;
  1393.                     * A, B, C : ARR (1..100);
  1394.                   * There is no need to split (reformat) this declaration.
  1395.                  * This reformat generates 3 types and therefore 3
  1396.                  * 3 type templates 
  1397.                  */
  1398.                 reformat = (N_AST2(type_indic_node) != OPT_NODE)
  1399.                   && reformat_requires (type_indic_node);
  1400.             }
  1401.             else        /* anonymous array.*/
  1402.                 reformat = TRUE;
  1403.         }
  1404.         else reformat = FALSE;
  1405.  
  1406.         if (reformat) {
  1407.             id_list = N_LIST(id_list_node);
  1408.             FORTUP(id_node = (Node), id_list, ft2);
  1409.                 new_decl = d;
  1410.                 if (tup_size(id_list) > 1) {
  1411.                     new_decl = copy_tree(d);
  1412.                     N_LIST(N_AST1(new_decl)) = tup_new1((char *) id_node);
  1413.                 }
  1414.                 newtypes = tup_with(newtypes, (char *) tup_new(0));
  1415.                 /* To collect anonymous types*/
  1416.                 adasem(new_decl);
  1417.                 type_list = (Tuple) tup_frome(newtypes);
  1418.                 FORTUP(pnode = (Node), process_anons(type_list), ft3);
  1419.                     decl_nodes = tup_with(decl_nodes, (char *)  pnode);
  1420.                 ENDFORTUP(ft3);
  1421.                 decl_nodes = tup_with(decl_nodes, (char *) new_decl);
  1422.                 /* A declaration like "a : array_type := (aggregate or
  1423.                  * qualification)" is split in two parts : a simple
  1424.                  * declaration, followed by an assignment.  The reason is the
  1425.                  * following : In the previous version there was a call to
  1426.                  * "array_ivalue", which makes a call to "compute_index".
  1427.                  * This is done to copy each component of the aggregate to its
  1428.                  * position in the array "a".  But, this can lead to incorrect
  1429.                  * results or to a constraint_error (incorrect subscript) in
  1430.                  * case of array sliding (the following assignement has to be
  1431.                  * performed : a (i) := aggregate (i + drift) instead of  a (i)
  1432.                  * := aggregate (i) ).  The solution we have chosen is the
  1433.                  * simplest and requires very little modifications.
  1434.                  */
  1435.                 if (init_node != OPT_NODE
  1436.                   && (N_AST2_DEFINED(N_KIND(type_indic_node)))
  1437.                   && (N_AST2(type_indic_node) != OPT_NODE)
  1438.                   && (is_record(TYPE_OF(N_UNQ(id_node)))
  1439.                   || (is_array(TYPE_OF(N_UNQ(id_node)))
  1440.                   && ((N_KIND (init_node) == as_qualify)
  1441.                   || (N_KIND (init_node) == as_array_aggregate))))) {
  1442.                     /* split object elaboration from actual assignment of
  1443.                     * initial value to constrained records
  1444.                     */
  1445.                     init = new_assign_node(copy_node(id_node),
  1446.                         N_AST3(new_decl));
  1447.                     N_AST3(new_decl) = OPT_NODE;
  1448.                     decl_nodes = tup_with(decl_nodes, (char *) init);
  1449.                 }
  1450.             ENDFORTUP(ft2);
  1451.             continue;
  1452.         }
  1453.         else {
  1454.             newtypes = tup_with(newtypes, (char *) tup_new(0));
  1455.             /* To collect anonymous types*/
  1456.             adasem(d);
  1457.             type_list  = (Tuple) tup_frome(newtypes);
  1458.             /* Create (sub)type declaration nodes for the anonymous types.*/
  1459.             anon_nodes = process_anons(type_list);
  1460.         }
  1461.     
  1462.         /* For record types, the anonymous types generated (which  may depend
  1463.          * on discriminants) are attached to the invariant part of the record
  1464.          * declaration, so that they may be emitted and elaborated within the
  1465.          * record.
  1466.           */
  1467.         if (N_KIND(d) == as_type_decl) {
  1468.             id_node = N_AST1(d);
  1469.             type_def = N_AST3(d);
  1470.             if (N_KIND(type_def) == as_record) {
  1471.                 component_list = N_AST1(type_def);
  1472.                 invariant_node = N_AST1(component_list);
  1473.                 FORTUP(a=(Node), anon_nodes, ft2);
  1474.                     if (N_KIND(a) == as_subtype_decl) {
  1475.                         nam = N_AST1(a);
  1476.                         if (TYPE_OF(N_UNQ(nam)) == N_UNQ(id_node)) {
  1477.                             /* We have an anonymous subtype of the current
  1478.                              * record type declaration. Mark it as a delayed
  1479.                              * type also.
  1480.                              */
  1481.                             decl_node = copy_node(a);
  1482.                             N_KIND(a) = as_delayed_type;
  1483.                             ancestor_node = new_name_node(N_UNQ(id_node));
  1484.                             N_AST1(a) = nam;
  1485.                             N_AST2(a) = ancestor_node;
  1486.                             N_AST3(a) = decl_node;
  1487.                         }
  1488.                     }
  1489.                 ENDFORTUP(ft2);
  1490.                 /* N_LIST(invariant_node) := anon_nodes */
  1491.                 /*    + N_LIST(invariant_node); */
  1492.                 tup = anon_nodes;
  1493.                 FORTUP(nod = (Node), N_LIST(invariant_node), ft2);
  1494.                     tup = tup_with(tup, (char *) nod);
  1495.                 ENDFORTUP(ft2);
  1496.                 N_LIST(invariant_node) = tup;
  1497.             }
  1498.             else {
  1499.                 /*decl_nodes +:= anon_nodes;*/
  1500.                 FORTUP(nod = (Node), anon_nodes, ft2);
  1501.                     decl_nodes = tup_with(decl_nodes, (char *) nod);
  1502.                 ENDFORTUP(ft2);
  1503.             }
  1504.         }
  1505.         else if (N_KIND(d) == as_subtype_decl) {
  1506.             id_node = N_AST1(d);
  1507.             subtype_indic = N_AST2(d);
  1508.             constraint = N_AST2(subtype_indic);
  1509.             if (constraint == OPT_NODE && !is_scalar_type(N_UNQ(id_node)) ) {
  1510.                 /* The subtype is a renaming of its parent, and does not 
  1511.                  *  appear in the code. Ignore the node.
  1512.                   */
  1513.                 /*    tup_free(anon_nodes);*/
  1514.                 continue;
  1515.             }
  1516.             else {
  1517.                 if (is_array(N_UNQ(id_node)) || (is_record(N_UNQ(id_node)))) {
  1518.                     /* discard anonymous array or record subtype to avoid 
  1519.                       * double elaboration 
  1520.                       */
  1521.                     nod = (Node) tup_frome(anon_nodes);
  1522.                     if (N_KIND (nod) != as_subtype_decl) {
  1523.                         /*  the last node may be a type declaration: case 
  1524.                           *  of derived type and therefore must not be removed 
  1525.                            */
  1526.                         anon_nodes = tup_with (anon_nodes, (char *) nod); 
  1527.                     }
  1528.                 }
  1529.                 /*decl_nodes +:= anon_nodes;*/
  1530.                 FORTUP(nod=(Node), anon_nodes, ft2);
  1531.                     decl_nodes = tup_with(decl_nodes, (char *) nod);
  1532.                 ENDFORTUP(ft2);
  1533.             }
  1534.         }
  1535.         else if (N_KIND(d) == as_num_decl ) {
  1536.             /* This represents declaration of a static universal constant
  1537.               *  which can be removed from the tree, since it needs to be noted 
  1538.               * only in the symbol table. The ivalue node representing the actual
  1539.               * value will be picked up by collect_unit_nodes.
  1540.               */
  1541.             continue;
  1542.         }
  1543.         else if (N_KIND(d) == as_rename_ex) {
  1544.             /* This represents a renaming of an exception which is handled
  1545.               * strictly in the symbol table and no longer needs to be in the
  1546.               * tree, so it is removed.
  1547.               */
  1548.             continue;
  1549.         }
  1550.         else {
  1551.             /*decl_nodes +:= anon_nodes;*/
  1552.             FORTUP(nod = (Node), anon_nodes, ft2);
  1553.                 decl_nodes = tup_with(decl_nodes, (char *) nod);
  1554.             ENDFORTUP(ft2);
  1555.         }
  1556.  
  1557.         decl_nodes = tup_with(decl_nodes, (char *) d);
  1558.         /*tup_free(anon_nodes);*/
  1559.     ENDFORTUP(ft1);
  1560.     N_LIST(node) = decl_nodes;
  1561. }
  1562.  
  1563. static Tuple process_anons(Tuple type_list)                    /*;process_anons*/
  1564. {
  1565.     Symbol    t;
  1566.     Node    nam, decl;
  1567.     Fortup    ft1;
  1568.     Tuple    anon_nodes;
  1569.  
  1570.     /* Create (sub)type declaration nodes for the anonymous types.*/
  1571.     anon_nodes = tup_new(0);
  1572.  
  1573.     FORTUP(t=(Symbol), type_list, ft1);
  1574.         nam = node_new(as_simple_name);
  1575.         N_UNQ(nam) = t;
  1576.         decl = node_new( NATURE(t) == na_subtype ? as_subtype_decl
  1577.           : as_type_decl );
  1578.         N_AST1(decl) = nam;
  1579.         N_AST2(decl) = OPT_NODE;
  1580.         if (N_KIND(decl) == as_type_decl)
  1581.             N_AST3(decl) = OPT_NODE;
  1582.         check_delayed_type(decl, t);
  1583.         anon_nodes = tup_with(anon_nodes, (char *)  decl );
  1584.     ENDFORTUP(ft1);
  1585.     return anon_nodes;
  1586. }
  1587.  
  1588. Symbol promote_subtype(Symbol subtype)                    /*;promote_subtype*/
  1589. {
  1590.     /* This     procedure is  called when a  subtype  indication  produces  an
  1591.      * anonymous type.  This occurs     when processing an object, constant or
  1592.      * subtype  declaration, when  processing  an iteration     scheme, or the
  1593.      * range  of an entry  family.    If the subtype is  already a type name,
  1594.      * it is returned as is.  If a previous subtype with the same structure
  1595.      * in the same scope was already promoted,  then that one  is returned.
  1596.      * Otherwise, the type mark is placed in the NEWTYPES stack, and atta-
  1597.      * ched to the current declaration.
  1598.      */
  1599.  
  1600.     Symbol parent_type;
  1601.     Tuple    t;
  1602.  
  1603.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  promote_subtype");
  1604.  
  1605.     if (! is_anonymous(subtype)) return subtype;
  1606.  
  1607.     t =(Tuple) newtypes[tup_size(newtypes)];
  1608.     /*TBSL see if can reallocate tuple in top(top...) calculation below */
  1609.     if (!tup_mem((char *) subtype, t))
  1610.         newtypes[tup_size(newtypes)] = (char *) tup_with(t, (char *) subtype);
  1611.     parent_type = TYPE_OF(subtype);
  1612.     root_type(subtype) = root_type(parent_type);
  1613.     misc_type_attributes(subtype) = misc_type_attributes(parent_type);
  1614.     return subtype;
  1615. }
  1616.  
  1617. Tuple subtype_expr(Symbol name)                            /*;subtype_expr*/
  1618. {
  1619.     /* OBSOLETE: used to generate AIS, return null tuple. */
  1620.  
  1621.     if (cdebug2 > 3) TO_ERRFILE("AT PROC: subtype_expr");
  1622.     return tup_new(0);
  1623. }
  1624.  
  1625. int is_character_type(Symbol name)                         /*;is_character_type*/
  1626. {
  1627.     /* An enumeration type is a character type if it contains at least one
  1628.      * character literal.
  1629.      */
  1630.  
  1631.     Symbol    bt;
  1632.     char        *c;
  1633.     int    i;
  1634.     Tuple    tup;
  1635.  
  1636.     if ( root_type(name) == symbol_character ) return TRUE;
  1637.     bt = base_type(name);
  1638.     if (NATURE(bt)    != na_enum) return FALSE;
  1639.     tup = (Tuple) literal_map(bt);
  1640.     for (i = 1; i <= tup_size(tup); i += 2) {
  1641.         c = tup[i];
  1642.         if (strlen(c) == 3 &&c[0] == '\'' && c[2] == '\'') return TRUE;
  1643.     }
  1644.     return FALSE;
  1645. }
  1646.  
  1647. int is_discrete_type(Symbol name) /*;is_discrete_type*/
  1648. {
  1649.     Symbol    btype;
  1650.  
  1651.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  is_discrete_type");
  1652.  
  1653.     if (TYPE_OF(name) != (Symbol)0) btype = root_type(name);
  1654.     else return FALSE;
  1655.  
  1656.     if (btype == symbol_integer
  1657.       || btype== symbol_universal_integer
  1658.       || btype == symbol_discrete_type
  1659.       || btype == symbol_any) return TRUE;
  1660.     if (NATURE(btype) == na_enum ) return TRUE;
  1661.     return FALSE;
  1662. }
  1663.  
  1664. int is_numeric(Symbol name)                                      /*;is_numeric*/
  1665. {
  1666.     Symbol r;
  1667.  
  1668.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  is_numeric");
  1669.  
  1670.     /* ??const numeric_types = {'INTEGER', 'FLOAT', '$FIXED',
  1671.      *  'universal_integer', 'universal_fixed', 'universal_real'};
  1672.      * return (root_type(name) ??in numeric_types );
  1673.      */
  1674.     r = root_type(name);
  1675.     return (r == symbol_integer || r == symbol_float 
  1676.       || is_fixed_type(r) || r == symbol_universal_integer
  1677.       || r == symbol_universal_real || r == symbol_universal_fixed );
  1678. }
  1679.  
  1680. int is_incomplete_type(Symbol t)                  /*;is_incomplete_type*/
  1681. {
  1682.     /* A type is incomplete if only an incomplete type declaration for it
  1683.      * has been seen, or if one of its subcomponents is an incomplete private
  1684.      * type (because of other rules, a subcomponent can never have an
  1685.      * incomplete type).
  1686.      */
  1687.  
  1688.     Symbol    b;
  1689.  
  1690.     b = base_type(t);
  1691.     return (TYPE_OF(b) == symbol_incomplete
  1692.       || private_ancestor(b) != (Symbol)0);
  1693. }
  1694.  
  1695. int is_unconstrained(Symbol typ)                     /*;is_unconstrained*/
  1696. {
  1697.     Symbol    discr;
  1698.     Fortup    ft1;
  1699.  
  1700.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  is_unconstrained");
  1701.  
  1702.     /*TBSL: check translation of this*/
  1703.     if    (NATURE(typ) == na_array) return TRUE;
  1704.     if (NATURE(typ) != na_record ) 
  1705.         if(!in_incp_types(TYPE_OF(typ))) return FALSE;
  1706.     /* Some discriminant has no default value.*/
  1707.     FORTUP(discr=(Symbol), (Tuple) discriminant_list(typ), ft1);
  1708.         if (discr == symbol_constrained) continue;
  1709.         if ((Node) default_expr(discr) == OPT_NODE ) return TRUE;
  1710.     ENDFORTUP(ft1);
  1711.     return FALSE;
  1712. }
  1713.  
  1714. Symbol base_type(Symbol name) /*;base_type*/
  1715. {
  1716.     Symbol    b;
  1717.  
  1718.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  base_type");
  1719.  
  1720.     /* It is possible to define subtypes of scalar subtypes. The base type
  1721.      * is then obtained by following the subtype chain until we reach a type
  1722.      */
  1723.     if (NATURE(name) == na_subtype) {
  1724.         b = TYPE_OF(name);
  1725.         while (NATURE(b) == na_subtype && b != name) {
  1726.             name = b;
  1727.             b = TYPE_OF(name);
  1728.         }
  1729.         return b;
  1730.     }
  1731.     else if (NATURE(name) == na_record || NATURE(name) == na_array)
  1732.         /* The type_of the array is its base type (it can be itself).*/
  1733.         return TYPE_OF(name);
  1734.     else
  1735.         return name;
  1736. }
  1737.  
  1738. Symbol named_type(char *name)  /*;named_type*/
  1739. {
  1740.     /* calls corresponding to the SETL named_type(str newat) send  & as first
  1741.      * character, so that they can be detected by the macro is_anonymous
  1742.      */
  1743.  
  1744.     Symbol    type_name;
  1745.     static int tint=0;
  1746.  
  1747.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  named_type");
  1748.  
  1749.     /* This procedure is invoked when an anonymous type can be given a name
  1750.      * that relates to its nature (e.g the base type of a derived type).
  1751.      */
  1752.     /* this is now obsolete -- newat_str() has already generated a unique string
  1753.      *    tint +=1;
  1754.      *    name = emalloc(6); -- t + 4 digits + null 
  1755.      *    sprintf(name, "t%04d", tint);
  1756.      */
  1757.     type_name =  sym_new(na_type);
  1758.     ORIG_NAME(type_name) = name;
  1759.     dcl_put(DECLARED(scope_name), name, type_name);
  1760.     SCOPE_OF(type_name) = scope_name;
  1761.     return type_name;
  1762. }
  1763.  
  1764. Symbol anonymous_type()                                     /*;anonymous_type*/
  1765. {
  1766.     /* This procedure is called to produce a new identifier for an anonymous
  1767.      * type. The new identifier is inserted into the symbol table, and into
  1768.      * the type stack.
  1769.      */
  1770.  
  1771.     Symbol    new_name;
  1772.     Tuple    t;
  1773.  
  1774.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  anonymous_type");
  1775.  
  1776.     new_name = named_atom("&anon");
  1777.     dcl_put(DECLARED(scope_name), str_newat(), new_name );
  1778.     SCOPE_OF(new_name) = scope_name;
  1779.     t = (Tuple) newtypes[tup_size(newtypes)];
  1780.     newtypes[tup_size(newtypes)] = (char *) tup_with(t, (char *) new_name);
  1781.     return new_name;
  1782. }
  1783.  
  1784. Symbol named_atom(char *id)                                     /*;named_atom*/
  1785. {
  1786.     /* This procedure uses the unique name generated for a compilation
  1787.      * unit to produce new names that will be unique throughout a library,
  1788.      * especially one containing more than one AIS file.
  1789.      */
  1790.     /* In C this returns a Symbol - the details of naming it are to
  1791.      * be resolved later        ds 4 aug
  1792.      */
  1793.  
  1794.     Symbol    s;
  1795.  
  1796.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  named_atom");
  1797.  
  1798.     s = sym_new(na_void);
  1799.     ORIG_NAME(s) = strjoin(id, "");
  1800.     return s;
  1801. #ifdef TBSN
  1802.     ??     return
  1803.  
  1804.         if unit_name(1) = 'body' then 'UB:' else '' end
  1805.     +/[unit_name(i) + '.' : i in [#unit_name, #unit_name-1..3]]
  1806.         + unit_name(2)
  1807.         + if unit_name(2) = '' then '' else '.' end
  1808.         + id
  1809.         + str newat;
  1810. #endif
  1811. }
  1812.  
  1813. int is_static_expr(Node node)                             /*;is_static_expr*/
  1814. {
  1815.     /* note - use statc since static is C keyword */
  1816.     int    statc, nat, nk;
  1817.     Fortup    ft1;
  1818.     Node    parm_node, gen_agg, aggregate, expression, opn;
  1819.     Node    arg2, attr, type_node;
  1820.     int    attrkind;
  1821.     Symbol n, prefix_type;
  1822.  
  1823.     if (cdebug2 > 3) TO_ERRFILE("AT PROC:is_static_expr ");
  1824.  
  1825.     if (N_TYPE(node) == symbol_any)    /* previous error */
  1826.         return TRUE;
  1827.  
  1828.     nk = N_KIND(node);
  1829.  
  1830.     if (nk == as_ivalue  || nk == as_int_literal
  1831.       || nk == as_real_literal || nk == as_character_literal)
  1832.         statc = TRUE;
  1833.     else if (nk == as_simple_name) {
  1834.         nat = NATURE(N_UNQ(node));
  1835.         if (nat == na_literal) statc = TRUE;
  1836.         else if (nat == na_constant)
  1837.             statc = is_static_expr((Node) SIGNATURE(N_UNQ(node)));
  1838.         else
  1839.             statc = FALSE;
  1840.     }
  1841.     else if (nk == as_un_op || nk == as_op) {
  1842.         statc = TRUE;
  1843.         opn = N_AST1(node);
  1844.         gen_agg = N_AST2(node);
  1845.         if ((N_UNQ(opn) == symbol_andthen)
  1846.           || (N_UNQ(opn) == symbol_orelse))
  1847.             statc = FALSE;
  1848.         FORTUP(parm_node =(Node), N_LIST(gen_agg), ft1);
  1849.             if (! is_static_expr(parm_node))
  1850.                 statc = FALSE;
  1851.         ENDFORTUP(ft1);
  1852.     }
  1853.     else if (nk == as_attribute) {
  1854.         attr = N_AST1(node);
  1855.         type_node = N_AST2(node);
  1856.         arg2 = N_AST3(node);
  1857.         attrkind = (int) attribute_kind(node);
  1858.  
  1859.         if (attrkind == ATTR_O_RANGE
  1860.           || attrkind == ATTR_T_RANGE
  1861.           || attrkind == ATTR_RANGE
  1862.           || attrkind == ATTR_O_LENGTH
  1863.           || attrkind == ATTR_T_LENGTH
  1864.           || attrkind == ATTR_LENGTH
  1865.           || attrkind == ATTR_FIRST_BIT
  1866.           || attrkind == ATTR_LAST_BIT
  1867.           || attrkind == ATTR_POSITION
  1868.           || attrkind == ATTR_TERMINATED
  1869.           || attrkind == ATTR_COUNT
  1870.           || attrkind == ATTR_CONSTRAINED
  1871.           || attrkind == ATTR_STORAGE_SIZE )
  1872.             return FALSE;
  1873.  
  1874.         if (N_KIND(type_node) != as_simple_name)
  1875.             prefix_type = N_TYPE(type_node);
  1876.         else {
  1877.             n = N_UNQ(type_node);
  1878.             if (is_type(n))
  1879.                 prefix_type = n;
  1880.             else
  1881.                 prefix_type = TYPE_OF(n);
  1882.         }
  1883.         if (is_generic_type(prefix_type))
  1884.             statc = FALSE;
  1885.         else {
  1886.             if (attrkind == ATTR_O_FIRST
  1887.               || attrkind == ATTR_T_FIRST
  1888.               || attrkind == ATTR_FIRST
  1889.               || attrkind == ATTR_O_LAST
  1890.               || attrkind == ATTR_T_LAST
  1891.               || attrkind == ATTR_LAST) {
  1892.                 if (is_array(prefix_type) )
  1893.                     statc = FALSE;
  1894.                 else
  1895.                     statc = is_static_subtype(prefix_type);
  1896.             }
  1897.             else if (attrkind == ATTR_POS
  1898.               || attrkind == ATTR_VAL 
  1899.               || attrkind == ATTR_SUCC
  1900.               || attrkind == ATTR_PRED
  1901.               || attrkind == ATTR_IMAGE
  1902.               || attrkind == ATTR_VALUE ) {
  1903.                 statc = is_static_subtype(prefix_type) &
  1904.                   is_static_expr(arg2);
  1905.             }
  1906.             else if (attrkind == ATTR_SIZE) {
  1907.                 if (N_KIND(type_node) == as_attribute 
  1908.                   && (int) attribute_kind(type_node) == ATTR_RANGE)
  1909. #ifdef ERRNUM
  1910.                     errmsgn(232, 233, type_node);
  1911. #else
  1912.                     errmsg("Invalid argument for attribute SIZE", "Annex A",
  1913.                       type_node);
  1914. #endif
  1915.                 statc = is_static_subtype(prefix_type);
  1916.             }
  1917.             else
  1918.                 /* May need further refinement. */
  1919.                 statc = TRUE;
  1920.         }
  1921.     }
  1922.     else if (nk == as_range_attribute)
  1923.         statc = FALSE;
  1924.     else if (nk == as_qualify) {
  1925.         /*type_mark = N_AST1(node); set but never used    ds 18 aug*/
  1926.         aggregate = N_AST2(node);
  1927.         statc = is_static_expr(aggregate);
  1928.     }
  1929.     else if (nk == as_parenthesis || nk == as_qual_range) {
  1930.         expression = N_AST1(node);
  1931.         statc = is_static_expr(expression);
  1932.     }
  1933.     else
  1934.         statc = FALSE;
  1935.  
  1936.     return statc;
  1937. }
  1938.  
  1939. /* the following function return FALSE if we have an array object
  1940.     declaration whose index subtypes are static. This will avoid
  1941.     the generation of n types (and n types templates) where n is
  1942.     the size of the object list */
  1943.  
  1944. static int reformat_requires(Node node_param) /*;reformat_requires*/
  1945. {
  1946.     Node    node, node1, ln;
  1947.     Fortup ftp1;
  1948.  
  1949.     if (N_KIND (node_param) == as_subtype_indic) {
  1950.         node = N_AST2 (node_param);
  1951.         if (N_KIND (node) != as_constraint ) 
  1952.             return TRUE; 
  1953.         if (N_LIST (node) == (Tuple) 0) 
  1954.             return TRUE; 
  1955.         FORTUP (ln= (Node), N_LIST (node), ftp1);
  1956.             if (N_KIND (ln) != as_subtype)
  1957.                 return TRUE;
  1958.             node1 = N_AST2 (ln);
  1959.             if (N_KIND (node1) != as_range) 
  1960.                 return TRUE;
  1961.             if (!is_static_expr (N_AST1 (node1))
  1962.               || !is_static_expr (N_AST2 (node1)))
  1963.                 return TRUE;
  1964.         ENDFORTUP (ftp1);
  1965.         return FALSE;
  1966.     }
  1967.     else
  1968.         return TRUE;
  1969. }
  1970.